home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / tcl / demos / mkRuler.tcl < prev    next >
Text File  |  1992-08-13  |  4KB  |  125 lines
  1. # mkRuler w
  2. #
  3. # Create a canvas demonstration consisting of a ruler.
  4. #
  5. # Arguments:
  6. #    w -    Name to use for new top-level window.
  7. # This file implements a canvas widget that displays a ruler with tab stops
  8. # that can be set individually.  The only procedure that should be invoked
  9. # from outside the file is the first one, which creates the canvas.
  10.  
  11. proc mkRuler {{w .ruler}} {
  12.     global tk_library
  13.     upvar #0 demo_rulerInfo v
  14.     catch {destroy $w}
  15.     toplevel $w
  16.     dpos $w
  17.     wm title $w "Ruler Demonstration"
  18.     wm iconname $w "Ruler"
  19.     set c $w.c
  20.  
  21.     frame $w.frame1 -relief raised -bd 2
  22.     canvas $c -width 14.8c -height 2.5c -relief raised
  23.     button $w.ok -text "OK" -command "destroy $w"
  24.     pack append $w $w.frame1 {top fill} $w.ok {bottom pady 10 frame center} \
  25.         $c {expand fill}
  26.     message $w.frame1.m -font -Adobe-Times-Medium-R-Normal-*-180-* -aspect 300 \
  27.         -text "This canvas widget shows a mock-up of a ruler.  You can create tab stops by dragging them out of the well to the right of the ruler.  You can also drag existing tab stops.  If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button."
  28.     pack append $w.frame1 $w.frame1.m {frame center}
  29.  
  30.     set v(grid) .25c
  31.     set v(left) [winfo fpixels $c 1c]
  32.     set v(right) [winfo fpixels $c 13c]
  33.     set v(top) [winfo fpixels $c 1c]
  34.     set v(bottom) [winfo fpixels $c 1.5c]
  35.     set v(size) [winfo fpixels $c .2c]
  36.     set v(normalStyle) "-fill black"
  37.     if {[winfo screendepth $c] > 4} {
  38.     set v(activeStyle) "-fill red -stipple {}"
  39.     set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \
  40.         -fill red"
  41.     } else {
  42.     set v(activeStyle) "-fill black -stipple {}"
  43.     set v(deleteStyle) "-stipple @$tk_library/demos/bitmaps/grey.25 \
  44.         -fill black"
  45.     }
  46.  
  47.     $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1
  48.     for {set i 0} {$i < 12} {incr i} {
  49.     set x [expr $i+1]
  50.     $c create line ${x}c 1c ${x}c 0.6c -width 1
  51.     $c create line $x.25c 1c $x.25c 0.8c -width 1
  52.     $c create line $x.5c 1c $x.5c 0.7c -width 1
  53.     $c create line $x.75c 1c $x.75c 0.8c -width 1
  54.     $c create text $x.15c .75c -text $i -anchor sw
  55.     }
  56.     $c addtag well withtag [$c create rect 13.2c 1c 13.8c 0.5c \
  57.         -outline black -fill [lindex [$c config -bg] 4]]
  58.     $c addtag well withtag [rulerMkTab $c [winfo pixels $c 13.5c] \
  59.         [winfo pixels $c .65c]]
  60.  
  61.     $c bind well <1> "rulerNewTab $c %x %y"
  62.     $c bind tab <1> "demo_selectTab $c %x %y"
  63.     bind $c <B1-Motion> "rulerMoveTab $c %x %y"
  64.     bind $c <Any-ButtonRelease-1> "rulerReleaseTab $c"
  65. }
  66.  
  67. proc rulerMkTab {c x y} {
  68.     upvar #0 demo_rulerInfo v
  69.     $c create polygon $x $y [expr $x+$v(size)] [expr $y+$v(size)] \
  70.         [expr $x-$v(size)] [expr $y+$v(size)]
  71. }
  72.  
  73. proc rulerNewTab {c x y} {
  74.     upvar #0 demo_rulerInfo v
  75.     $c addtag active withtag [rulerMkTab $c $x $y]
  76.     $c addtag tab withtag active
  77.     set v(x) $x
  78.     set v(y) $y
  79.     rulerMoveTab $c $x $y
  80. }
  81.  
  82. proc rulerMoveTab {c x y} {
  83.     upvar #0 demo_rulerInfo v
  84.     if {[$c find withtag active] == ""} {
  85.     return
  86.     }
  87.     set cx [$c canvasx $x $v(grid)]
  88.     set cy [$c canvasy $y]
  89.     if {$cx < $v(left)} {
  90.     set cx $v(left)
  91.     }
  92.     if {$cx > $v(right)} {
  93.     set cx $v(right)
  94.     }
  95.     if {($cy >= $v(top)) && ($cy <= $v(bottom))} {
  96.     set cy [expr $v(top)+2]
  97.     eval "$c itemconf active $v(activeStyle)"
  98.     } else {
  99.     set cy [expr $cy-$v(size)-2]
  100.     eval "$c itemconf active $v(deleteStyle)"
  101.     }
  102.     $c move active [expr $cx-$v(x)] [expr $cy-$v(y)]
  103.     set v(x) $cx
  104.     set v(y) $cy
  105. }
  106.  
  107. proc demo_selectTab {c x y} {
  108.     upvar #0 demo_rulerInfo v
  109.     set v(x) [$c canvasx $x $v(grid)]
  110.     set v(y) [expr $v(top)+2]
  111.     $c addtag active withtag current
  112.     eval "$c itemconf active $v(activeStyle)"
  113.     $c raise active
  114. }
  115.  
  116. proc rulerReleaseTab c {
  117.     upvar #0 demo_rulerInfo v
  118.     if {$v(y) != [expr $v(top)+2]} {
  119.     $c delete active
  120.     } else {
  121.     eval "$c itemconf active $v(normalStyle)"
  122.     $c dtag active
  123.     }
  124. }
  125.